home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / examples / old / demo / grapher.l < prev    next >
Encoding:
Text File  |  1989-07-12  |  28.8 KB  |  712 lines
  1. ;;; -*- Mode:Lisp; Package:CLUE-EXAMPLES; Lowercase:T; Base:10; Syntax:Common-Lisp -*-
  2. ;;;
  3. ;;;             TEXAS INSTRUMENTS INCORPORATED
  4. ;;;                  P.O. BOX 2909
  5. ;;;                   AUSTIN, TEXAS 78769
  6. ;;;
  7. ;;; Copyright (C) 1988 Texas Instruments Incorporated.
  8. ;;;
  9. ;;; Permission is granted to any individual or institution to use, copy, modify,
  10. ;;; and distribute this software, provided that this complete copyright and
  11. ;;; permission notice is maintained, intact, in all copies and supporting
  12. ;;; documentation.
  13. ;;;
  14. ;;; Texas Instruments Incorporated provides this software "as is" without
  15. ;;; express or implied warranty.
  16. ;;;
  17.  
  18.  
  19. ;;; Change History:
  20. ;;; ----------------------------------------------------------------------------
  21. ;;;  7/01/88    SLM    Created.
  22. ;;;  8/19/88    LGO    Replaced reference to managed-p with contact-state
  23. ;;;  8/19/88    LGO    Cleaned up implementation of graph-menu
  24. ;;;  8/19/88    LGO    Use :background keyword to set contact background
  25. ;;;  8/19/88    LGO    make moveoutline re-entrant, parent-relative, eliminate
  26. ;;;            use of a "state" slot, and initialize correctly.
  27. ;;;  8/23/88    SLM     Convert Zetalisp LOOP into Common Lisp DO and DOLIST.
  28. ;;;  8/23/88    SLM     Get rid of a bunch of debug statements, variables and routines.
  29. ;;;  8/23/88    SLM     Make VERTEX, EDGE, and GRAPH-COMPOSITE use resources for 
  30. ;;;                     various slot values.
  31.  
  32.  
  33. (in-package 'clue-examples :use '(lisp xlib clos cluei))
  34.  
  35.  
  36.  
  37. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  38. ;;; Global variables
  39.  
  40.  
  41. (defvar *graph-menu*)
  42. (defvar *graph-command-menu-alist* '((change-name :title "Change Name")
  43.                      (other-menu :title "other menu")))
  44. (defvar *moveoutline* nil)
  45.  
  46.  
  47.  
  48. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49. ;;; Utility routines
  50.  
  51. ;;; This function builds a closure; the closure variables record the size/location
  52. ;;; of how the outline box was last drawn.  The arguments to the closure are:
  53. ;;;  root - a window to draw on
  54. ;;;  X,Y  - the upper left corner of the outline box
  55. ;;;  width, heigth - the size of the outline box
  56. ;;; When the closure is called with a width or height of 0, then the previously drawn
  57. ;;; box is erased, and no additional box is drawn
  58. (defun make-moveoutline (window)
  59.   "Return a closure of four keyword arguments, x y width and height.  It draws two rectangles
  60. one to erase the last rectangle drawn and one new rectangle.  The first time called it draws only one.
  61. To only erase the last outline call it with width or height of 0."
  62.   (let ((lastx 0)
  63.     (lasty 0)
  64.     (lastwidth 0)
  65.     (lastheight 0)
  66.     (outline (make-array 8 :initial-element 0 :fill-pointer 0))
  67.     indx)
  68.     #'(lambda (&key (x lastx) (y lasty) (width lastwidth) (height lastheight))
  69.     (setq indx 0)
  70.     (unless (and (= x lastx) (= y lasty) (= width lastwidth) (= height lastheight))
  71.       ;;when everything is zero, there's no rectangle to erase
  72.       (unless (or (zerop lastwidth) (zerop lastheight))
  73.         (setf (aref outline indx) lastx
  74.           (aref outline (1+ indx)) lasty
  75.           (aref outline (+ 2 indx)) lastwidth
  76.           (aref outline (+ 3 indx)) lastheight
  77.           indx (+ indx 4)))
  78.       ;;draw-rectangles has problems when the width or height is negative,
  79.       ;;so we'll "shift" the rectangle's origin so width and height are positive.
  80.       (if (minusp width)
  81.           (setf lastx (+ x width)
  82.             lastwidth (- width))
  83.           (setf lastx x
  84.             lastwidth width))
  85.       (if (minusp height)
  86.           (setf lasty (+ y height)
  87.             lastheight (- height))
  88.           (setf lasty y
  89.             lastheight height))
  90.       ;;when everything is zero, there's no new rectangle to draw
  91.       (unless (or (zerop lastwidth) (zerop lastheight))
  92.         (setf (aref outline indx) lastx
  93.           (aref outline (1+ indx)) lasty
  94.           (aref outline (+ 2 indx)) lastwidth
  95.           (aref outline (+ 3 indx)) lastheight
  96.           indx (+ indx 4)))
  97.       ;;don't make a request unless there's something to draw...
  98.       (when (> indx 0)
  99.         ;;...and only draw as many rectangles as you need
  100.         (setf (fill-pointer outline) indx)
  101.         (using-gcontext (xorgc :drawable window
  102.                    :foreground 1 :background 0 :function boole-xor
  103.                    :subwindow-mode :include-inferiors)
  104.           (draw-rectangles window xorgc outline)))))))
  105.  
  106. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  107. ;;; VERTICES
  108.  
  109. (defcontact vertex (button)
  110.   ((object :type t :accessor object :initform nil :initarg :object)
  111.    (edges-in :type (or null list) :accessor edges-in :initform nil :initarg :edges-in)
  112.    (edges-out :type (or null list) :accessor edges-out :initform nil :initarg :edges-out)
  113.    (visited-p :type boolean :accessor visited-p :initform nil :initarg :visited-p)
  114.    ;(undo-info :type list :accessor undo-info :initform nil)
  115.    (name-function :type (or null function) :accessor name-function :initform nil :initarg :name-function)
  116.    (ptr-rel-x :type integer :accessor :ptr-rel-x :initform 0)
  117.    (ptr-rel-y :type integer :accessor :ptr-rel-y :initform 0)
  118.    (foreground :type pixel :accessor :foreground
  119.            :initform 0 :initarg :foreground)
  120.    ;(highlight-function :type keyword :accessor highlight-function :initform nil :initarg)
  121.    (documentation :type t :accessor :documentation :initarg :documentation)
  122.    (compress-exposures :initform t)
  123.    )
  124.   (:resources
  125.     (border-width :initform 1)
  126.     foreground
  127.     (background :initform 1)
  128.     (documentation :initform "Click left and drag to move this vertex")
  129.     (font :initform "fg-18"))
  130.   )
  131.  
  132.  
  133. ;;; When the button goes down start drawing the moving outline for the WM-FRAME.
  134. (defmethod start-vertex ((mover vertex))
  135.   (with-event ((pointer-x x) (pointer-y y))
  136.     (with-slots (display parent x y ptr-rel-x ptr-rel-y width height) mover
  137.       (setf ptr-rel-x (- pointer-x x)
  138.         ptr-rel-y (- pointer-y y))
  139.       ;; draw the outline the first time
  140.       (let ((*moveoutline* (make-moveoutline parent)))
  141.     (funcall *moveoutline* :x x :y y :width width :height height)
  142.     (with-mode (mover)
  143.       (catch 'done
  144.         (do ()
  145.         (())
  146.           (process-next-event display))))))))
  147.  
  148. ;;;--------------------------------------------
  149. ;;; This is the move action for the VERTEX
  150. ;;; Move the outline with the pointer
  151. (defmethod move-vertex ((mover vertex))
  152.   (declare (special *moveoutline*))
  153.   (with-event ((pointer-x x) (pointer-y y))
  154.     (with-slots (ptr-rel-x ptr-rel-y) mover
  155.       (when *moveoutline*
  156.     ;; draw the outline
  157.     (funcall *moveoutline* :x (- pointer-x ptr-rel-x) :y (- pointer-y ptr-rel-y))))))
  158.  
  159. ;;;--------------------------------------------
  160. ;;; This is the button release action for VERTEX
  161. ;;; Erase the moving outline and move the vertex
  162. (defmethod finish-vertex ((mover vertex))
  163.   (declare (special *moveoutline*))
  164.   (with-event ((pointer-x x) (pointer-y y))
  165.     (with-slots (ptr-rel-x ptr-rel-y)
  166.         mover
  167.       ;; if moving, change the position of the frame,
  168.       ;; otherwise make priority opposite what it is now
  169.       (when *moveoutline*
  170.     (funcall *moveoutline* :width 0)    ;turn off the moving outline
  171.     (move mover (- pointer-x ptr-rel-x) (- pointer-y ptr-rel-y))
  172.     (dolist (edge (edges-in mover))
  173.           (display edge 0 0 0 0 :calculate-p t))
  174.     (dolist (edge (edges-out mover))
  175.       (display edge 0 0 0 0 :calculate-p t))
  176.     (throw 'done nil)))))
  177.  
  178. ;;;---------------------------------------------
  179. ;;; This is the right-click action for VERTEX.
  180. ;;; Put up a command menu of things that can be done with the vertex.
  181.  
  182. (defun graph-command-menu (x y parent )
  183.   (if *graph-menu*  ;; First time, create the menu
  184.     (add-mode *graph-menu* :exclusive 'ignore-action)
  185.     (setf *graph-menu*
  186.       (menu-choose parent
  187.                *graph-command-menu-alist*
  188.                :handler 'graph-command-menu-handler
  189.                :multiple-p nil)))
  190.   (change-priority *graph-menu* :above)
  191.   (change-geometry *graph-menu* :x x :y y)
  192.   (setf (contact-state *graph-menu*) :mapped))
  193.  
  194.  
  195. (defun graph-command-menu-handler (selection)
  196.   (delete-mode *graph-menu*)
  197.   (setf (contact-state *graph-menu*) :withdrawn)
  198.   #+explorer
  199.   (case (car selection)
  200.     (change-name (ticl:beep :doorbell))
  201.     (other-menu (ticl:beep :zowie)))
  202.   (case (car selection)
  203.     (change-name (print "Change Name"))
  204.     (other-menu (print "Other Menu"))))
  205.  
  206. (defmethod action-graph-command-menu ((mover vertex))
  207.   (with-event (root-x root-y)
  208.     (with-slots (parent) mover
  209.       (graph-command-menu root-x root-y parent ))))
  210.  
  211. ;;;;--------------------------------------------
  212. ;;;; This is the double-click action for VERTEX
  213. ;;;; Put up a command menu of things that can be done with the frame
  214. ;(defmethod xwm-command-menu ((mover vertex))
  215. ;  (with-event (root-x root-y)
  216. ;    (with-slots (parent) mover
  217. ;      (xwm-command-menu root-x root-y parent))))
  218.  
  219. ;;;----------------------------------------------------------------------
  220. ;;; here are the event definitions for the VERTEX
  221. (defevent vertex (:button-press   :button-1) start-vertex)
  222. (defevent vertex (:motion-notify  :button-1) move-vertex)
  223. (defevent vertex (:button-release :button-1) finish-vertex)
  224. (defevent vertex (:button-press   :button-3) action-graph-command-menu   (action-display :highlight nil))
  225. ;;(defevent vertex (:button-press   :button-1 :double-click) xwm-command-menu)
  226.  
  227. (defmethod add-outgoing-edge ((self vertex) edge)
  228.   (with-slots (edges-out) self
  229.     (setf edges-out (pushnew edge edges-out))))
  230.  
  231.  
  232. (defmethod add-incoming-edge ((self vertex) edge)
  233.   (with-slots (edges-in) self
  234.     (setf edges-in (pushnew edge edges-in))))
  235.  
  236.  
  237.  
  238. (defmethod midpoint ((self vertex) &key (side nil))
  239.   (with-slots (x y width height) self
  240.     (case side
  241.       (:top (values (+ x (round (/ width 2.))) y))
  242.       (:right (values (+ x width) (+ y (round (/ height 2.)))))
  243.       (:bottom (values (+ x (round (/ width 2.))) (+ y height)))
  244.       (:left (values x (+ y (round (/ height 2.)))))
  245.       (otherwise (values (+ x (round (/ width 2.))) (+ y (round (/ height 2.))))))
  246.     ))
  247.  
  248. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  249. ;;;  EDGES
  250.  
  251. (defcontact edge (virtual)
  252.   ((to-node :type t :accessor to-node :initform nil :initarg :to-node)
  253.    (from-node :type t :accessor from-node :initform nil :initarg :from-node)
  254.    (x1 :type integer :accessor x1 :initform 0 :initarg :x1)
  255.    (y1 :type integer :accessor y1 :initform 0 :initarg :y1)
  256.    (x2 :type integer :accessor x2 :initform 0 :initarg :x2)
  257.    (y2 :type integer :accessor y2 :initform 0 :initarg :y2)
  258.    (px :type integer :accessor px :initform 0 :initarg :px)
  259.    (py :type integer :accessor py :initform 0 :initarg :py)
  260.    (pname :type (or null string) :accessor pname :initform nil :initarg :pname)
  261.    (visited-p :type boolean :accessor visited-p :initform nil :initarg :visited-p)
  262.    (edge-type :type (or null keyword) :accessor edge-type :initform nil :initarg :edge-type)
  263.    (text-font :type (or null font) :accessor text-font :initarg :text-font)
  264.    (line-style :type (member :solid :dash :double-dash) :initarg :line-style)
  265.    (line-width :type card16 :initarg :line-width)
  266.    (foreground :type pixel :initform 0 :initarg :foreground)
  267.    (background :type (or (member :none :parent-relative) pixel pixmap) :initform 1 :initarg :background)
  268. ;   (compress-exposures :type (member :on :off) :accessor compress-exposures :initform :on :initarg :compress-exposures)
  269.    ;(undo-info :type list :accessor undo-info :initform nil)
  270.    )
  271.   (:resources
  272.     x1 y1 x2 y2 px py
  273.     background foreground
  274.     (text-font :initform "fg-13")
  275.     (line-style :initform :solid)
  276.     (line-width :initform 3))
  277.   )
  278.  
  279. (defmethod cluei:initialize-geometry ((edge edge))
  280.   ;nuthin
  281.   )
  282. (defmethod cluei:initial-state-transition ((edge edge))
  283.     "Return the old-state/new-state for the initial (setf contact-state) after edge
  284.    is realized. Return nil if (setf contact-state) need not be called, i.e. no
  285.    initial state transition is necessary."
  286.   (with-slots (state) edge
  287.     (when (eq :mapped state)
  288.       (values :managed :mapped))))
  289.  
  290. (defmethod midpoint ((self edge) &key)
  291.   (values (+ (x1 self) (round (/ (x2 self) 2.))) (+ (y1 self) (round (/ (y2 self) 2.)))))
  292.  
  293.  
  294. (defmethod display ((self edge) &optional x y width height &key (calculate-p t))
  295.   (declare (ignore x y width height))
  296.   (with-slots (to-node from-node pname x1 y1 x2 y2 px py background foreground line-style line-width text-font parent) self
  297.     (using-gcontext (gcontext :drawable parent :background background :foreground foreground
  298.                   :line-style line-style :line-width line-width :font text-font)
  299.       (when calculate-p
  300.     (using-gcontext (gc :drawable parent :default gcontext
  301.                 :foreground background :background foreground
  302.                 :line-style line-style :line-width line-width
  303.                 :font text-font)
  304.       (draw-line parent gc x1 y1 x2 y2)
  305.       (when pname
  306.         (draw-glyphs parent gc px py pname)))
  307.     (multiple-value-bind (x y)
  308.         (midpoint from-node :side :right)
  309.       (setf x1 x y1 y))
  310.     (multiple-value-bind (x y)
  311.         (midpoint to-node :side :left)
  312.       (setf x2 x y2 y))
  313.     (when pname
  314.       (multiple-value-bind (x y)
  315.           (midpoint self)
  316.         (setf px x py y))
  317.       (setf px (- px (round (/ (text-width (gcontext-font gcontext) pname) 2.))))))
  318.       (draw-line parent gcontext x1 y1 x2 y2)
  319.       (when pname
  320.     (draw-glyphs parent gcontext px py pname)))))
  321.  
  322. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  323. ;;; GRAPH COMPOSITE
  324.  
  325. ;;Has to be a VIRTUAL-COMPOSITE so virtual-children get the exposure events
  326. (defcontact graph-composite (virtual-composite)
  327.   ((x-spacing :type integer :accessor x-spacing :initform 20 :initarg :x-spacing)
  328.    (y-spacing :type integer :accessor y-spacing :initform 8 :initarg :y-spacing)
  329.    (x-margin :type integer :accessor x-margin :initform 5 :initarg :x-margin)
  330.    (y-margin :type integer :accessor y-margin :initform 5 :initarg :y-margin)
  331.    ;(undo-info :type list :accessor undo-info :initform nil :initarg :undo-info)
  332.    (orientations :type list :accessor orientations :initform '(:horizontal :vertical) :initarg :orientations)
  333.    (root-list :type list :accessor root-list :initform nil :initarg :root-list)
  334.    (vertex-info-alist :type list :accessor vertex-info-alist :initform nil :initarg :vertex-info-alist)
  335.    (edge-info-alist :type list :accessor edge-info-alist :initform nil :initarg :edge-info-alist)
  336.    (foreground :type pixel :accessor foreground
  337.            :initform 0 :initarg :foreground)
  338.    (documentation :type t :accessor :documentation :initarg :documentation)
  339.    (compress-exposures :initform :on)
  340.   )
  341.   (:resources
  342.     x-spacing y-spacing
  343.     x-margin y-margin
  344.     orientations
  345.     foreground
  346.     (background :initform 1)
  347.     (documentation :initform "Press the Q key to exit the grapher"))
  348.   )
  349.  
  350.  
  351. (defmethod quit-graph ((graph graph-composite) &optional (tag 'quit-graph) value)
  352.   (format t "~%~a ~a ~a" graph tag value)
  353.   (throw tag value))
  354.  
  355.  
  356. (defevent graph-composite (:key-press #\q) (quit-graph quit-graph "key-exit"))
  357. (defevent graph-composite (:key-press #\Q) (quit-graph quit-graph "key-exit"))
  358.  
  359.  
  360. (defmethod current-orientation ((self graph-composite))
  361.   (car (orientations self)))
  362.  
  363.  
  364. (defmethod toggle-orientation ((self graph-composite))
  365.   (with-slots (x-spacing y-spacing orientations) self
  366.     (psetf x-spacing y-spacing
  367.        y-spacing x-spacing
  368.        orientations (append (cdr orientations) (list (car orientations))))))
  369.  
  370. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  371. ;;; Access routines
  372.  
  373. (defmethod vertex-children ((self vertex) &optional (edge-type :all))
  374.   (let (vertices)
  375.     (dolist (edge (edges-out self) vertices)
  376.       (if (atom edge-type)
  377.       (or (equal (edge-type edge) edge-type)
  378.           (eq edge-type :all))
  379.       (or (find (edge-type edge) edge-type)
  380.           (find :all edge-type)))
  381.       (pushnew (to-node edge) vertices))
  382.     ))
  383.  
  384. (defmethod vertex-parents ((self vertex) &optional (edge-type '(:all)))
  385.   (let (vertices)
  386.   (dolist (edge (edges-in self) vertices)
  387.     (if (atom edge-type)
  388.     (or (equal (edge-type edge) edge-type)
  389.         (eq edge-type :all))
  390.     (or (find (edge-type edge) edge-type)
  391.         (find :all edge-type)))
  392.     (pushnew (from-node edge) vertices))
  393.   ))
  394.  
  395. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  396. ;;;  Graph layout
  397.  
  398. (defmethod compute-in-x-direction ((self graph-composite) &optional
  399.                    &key (node-list nil) (x-start nil) (edge-type t) (forget-p nil))
  400.   "NODE-LIST the are nodes to place; X-START is the x pixel position to place the left-most edge;
  401. EDGE-TYPE is a list of the edges to traverse when deciding which children to adjust as well, or T to mean all edges;
  402. when FORGET-P is non-nil it means recompute the x co-ordinate even if the user has explicitly positioned
  403. the vertex at that place."
  404.   (declare (type list node-list)
  405.        (type (or null integer) x-start)
  406.        (type (or keyword string) edge-type)) 
  407.   (when node-list
  408.     (with-slots (x-spacing x-margin root-list) self
  409.       (unless x-start (setq x-start x-margin))
  410.       (unless node-list (setq node-list root-list))
  411.       (let* ((max-x-pos 0) 
  412.          (children nil))
  413.     (dolist (node node-list)
  414.       ;;Move the node if it has not already been visited, 
  415.       ;;and if the user did not explicitly place it somewhere
  416.       (when forget-p (setf (contact-state (the contact node)) nil))
  417.       (unless (or (visited-p node)
  418.               (not (managed-p node)))
  419.         (move node x-start (contact-y node))
  420.         (setf max-x-pos (max max-x-pos (+ x-start (contact-width node))))
  421.         (setf (visited-p node) t)))
  422.     ;;Find the next x starting position
  423.     (setq max-x-pos (+ max-x-pos x-spacing))
  424.     (dolist (node node-list)
  425.       (dolist (edge (edges-out node))
  426.         (when (and (not (visited-p edge))
  427.                (if (atom edge-type)
  428.                (or (equal (edge-type edge) edge-type) edge-type)
  429.                (member (edge-type edge) edge-type #'equal)))
  430.           (pushnew (to-node edge) children))
  431.         (setf (visited-p edge) t))
  432.       )
  433.     (when children
  434.       (compute-in-x-direction self :node-list children :x-start max-x-pos :edge-type edge-type :forget-p forget-p))
  435.     ))))
  436.  
  437.  
  438.  
  439. (defmethod compute-in-y-direction ((self graph-composite) &optional
  440.                    &key (node-list nil) (edge-type t) (y-start nil))
  441.   "NODE-LIST are the nodes to place; EDGE-TYPE is a list of the edges to 
  442. traverse when deciding which children to adjust as well, or T to mean all edges."
  443.   (declare (type list node-list)
  444.        (type (or null integer) y-start)
  445.        (type (or keyword string) edge-type)) 
  446.   (with-slots (y-spacing y-margin root-list) self
  447.     (unless y-start (setq y-start y-margin))
  448.     (unless node-list (setq node-list root-list))
  449.     (let* ((accumulated-height 0)
  450.        (y-height 0)
  451.        (new-y-start y-start)
  452.        (vertex-children nil))
  453.       ;;Edges and nodes that were visited by the X layout have been marked as visited.
  454.       ;;As we touch nodes and edges THIS time, we UNmark them!!!
  455.       ;;THEREFORE, move the node IFF it HAS already been visited, 
  456.       ;;and if the user did not explicitly place it somewhere
  457.       (dolist (node node-list) 
  458.     (if (and (visited-p node) (managed-p node))
  459.         (progn 
  460.           (setf (visited-p node) nil)  ;;unset the node's flag!!!
  461.           (dolist (edge (edges-out node))
  462.         (when (and (visited-p edge)
  463.                (if (atom edge-type)
  464.                (or (equal (edge-type edge) edge-type) edge-type)
  465.                (find (edge-type edge) (the list edge-type) #'equal)))
  466.             (pushnew (to-node edge) vertex-children))
  467.         (setf (visited-p edge) nil))  ;;unset the edge's flag!!!
  468.           (if vertex-children
  469.           (setq y-height (compute-in-y-direction self :node-list vertex-children
  470.                              :edge-type edge-type :y-start new-y-start))
  471.           (setq y-height (+ (* 2 (contact-border-width node)) (contact-height node)))) 
  472.           (move node (contact-x node) (max new-y-start
  473.                            (- (+ new-y-start (round (/ y-height 2.)))
  474.                           (round (/ (+ (* 2 (contact-border-width node)) (contact-height node)) 2.))))))
  475.         (setf (visited-p node) nil)) 
  476.     (setf new-y-start (+ y-spacing y-height new-y-start)
  477.           accumulated-height (+ (+ y-spacing y-height) accumulated-height)))
  478.       accumulated-height)))
  479.  
  480.  
  481. (defmethod compute-graph-layout ((self graph-composite) &optional (node-list nil)) 
  482.   (with-slots (root-list width height) self
  483.     (compute-in-x-direction self :node-list (or node-list root-list))
  484.     (compute-in-y-direction self :node-list (or node-list root-list))
  485.     (display self 0 0 width height)))
  486.  
  487. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  488. ;;; Initializations
  489.  
  490. (defmethod preprocess-edge-info ((self graph-composite) edge-info &aux (edge-names nil) association)
  491.   "Hang the infromation in EDGE_INFOR on SELF.  Return the edge-names that were processed."
  492.   (with-slots (edge-info-alist) self
  493.     (dolist (stuff edge-info)
  494.       (pushnew (car stuff) edge-names)
  495.       (if (setq association (assoc (car stuff) edge-info-alist))
  496.       (setf edge-info-alist (cons stuff (delete association edge-info-alist)))
  497.       (setf edge-info-alist (cons stuff edge-info-alist)))
  498.       ))
  499.   edge-names)
  500.  
  501.  
  502. (defmethod preprocess-vertex-info ((self graph-composite) vertex-info &aux association)
  503.   "Hang the information in VERTEX-INFO on SELF.  No meaningful return"
  504.   (with-slots (vertex-info-alist) self
  505.     (dolist (stuff vertex-info)
  506.       (if (setq association (assoc (car stuff) vertex-info-alist))
  507.       (setf vertex-info-alist (cons stuff (delete association vertex-info-alist)))
  508.       (setf vertex-info-alist (cons stuff vertex-info-alist)))
  509.       )))
  510.  
  511.  
  512. (defmethod vertex-font-function-info ((self graph-composite))
  513.   "Return the font-function for vertices"
  514.   (cadr (assoc :font-function (vertex-info-alist self))))
  515.  
  516.  
  517. (defmethod vertex-background-info ((self graph-composite))
  518.   "Return the background for vertices"
  519.   (cadr (assoc :background (vertex-info-alist self))))
  520.  
  521.  
  522. (defmethod vertex-foreground-info ((self graph-composite))
  523.   "Return the foreground for vertices"
  524.   (cadr (assoc :foreground (vertex-info-alist self))))
  525.  
  526.  
  527. (defmethod edge-line-style-info ((self graph-composite) edge)
  528.   "Return the line-style specification for an edge of type EDGE"
  529.   (when (typep edge 'edge) (setq edge (edge-type edge)))
  530.   (cadr (assoc :line-style (cdr (assoc edge (edge-info-alist self))))))
  531.  
  532.  
  533. (defmethod edge-line-width-info ((self graph-composite) edge)
  534.   "Return the line-width specification for an edge of type EDGE"
  535.   (when (typep edge 'edge) (setq edge (edge-type edge)))
  536.   (cadr (assoc :line-width (cdr (assoc edge (edge-info-alist self))))))
  537.  
  538.  
  539. (defmethod edge-foreground-info ((self graph-composite) edge)
  540.   "Return the line-foreground specification for an edge of type EDGE"
  541.   (when (typep edge 'edge) (setq edge (edge-type edge)))
  542.   (cadr (assoc :line-foreground (cdr (assoc edge (edge-info-alist self))))))
  543.  
  544.  
  545. (defmethod edge-background-info ((self graph-composite) edge)
  546.   "Return the line-background specification for an edge of type EDGE"
  547.   (when (typep edge 'edge) (setq edge (edge-type edge)))
  548.   (cadr (assoc :line-background (cdr (assoc edge (edge-info-alist self))))))
  549.  
  550.  
  551. (defmethod edge-text-info ((self graph-composite) edge)
  552.   "Return the font specification for an edge of type EDGE"
  553.   (when (typep edge 'edge) (setq edge (edge-type edge)))
  554.   (cadr (assoc :edge-font (cdr (assoc edge (edge-info-alist self))))))
  555.  
  556.  
  557. (defmethod edge-parents-function ((self graph-composite) edge)
  558.   "Return the function that should be used on a vertex's object to get the list of parent objects."
  559.   (when (typep edge 'edge) (setq edge (edge-type edge)))
  560.   (cadr (assoc :parents (cdr (assoc edge (edge-info-alist self))))))
  561.  
  562.  
  563. (defmethod edge-children-function ((self graph-composite) edge)
  564.   "Return the function that should be used on a vertex's object to get the list of child objects."
  565.   (when (typep edge 'edge) (setq edge (edge-type edge)))
  566.   (cadr (assoc :children (cdr (assoc edge (edge-info-alist self))))))
  567.  
  568.  
  569. (defun find-all-objects (wind node-list edge-type &optional (return-list nil) (duplicate-exists-p nil))
  570.   "Find all objects to be included in the graph, starting with NODE-LIST.
  571. Use the edge-info stored in WIND for each edge-type in EDGE-TYPE to obtain the children to be included."
  572.   (let* ()
  573.     (dolist (node node-list)
  574.       (if (find node return-list :test #'equal)
  575.       (push node duplicate-exists-p)
  576.       (push node return-list))
  577.       (multiple-value-setq (return-list duplicate-exists-p)
  578.     (find-all-objects wind (funcall (edge-children-function wind edge-type) node)
  579.                edge-type return-list duplicate-exists-p)))
  580.     (values return-list duplicate-exists-p)))
  581.  
  582.  
  583. (defun add-edges (parent-window node-list all-nodes edge-type
  584.           &optional
  585.           (edge-children-function nil)
  586.           (edge-line-style nil)
  587.           (edge-line-width nil)
  588.           (edge-foreground nil)
  589.           (edge-background nil)
  590.           (edge-text-font nil))
  591.   "Add the edges for the graph to be displayed in PARENT-WINDOW.  NODE-LIST is a starting 
  592. list of sibling vertex objects/names;  ALL-NODES is the list of all known vertex contacts 
  593. in this graph; EDGE-TYPE is the name (usually a keyword) of edge type we want to add. The 
  594. optional arg EDGE-CHILDREN-FUNCTION is the function to call on each node in NODE-LIST to 
  595. obtain the children of this edge relationship (default function stored on parent-window)."
  596.   (let (vertex-children
  597.     edge
  598.     (width (contact-width parent-window))
  599.     (height (contact-height parent-window)))
  600.     (unless edge-children-function (setq edge-children-function
  601.                      (edge-children-function parent-window edge-type)))
  602.     (dolist (node node-list)
  603.       (setq vertex-children (funcall edge-children-function node)
  604.         node (cadr (assoc node all-nodes :test #'equal)))
  605.       (dolist (child vertex-children)
  606.     (setq child (cadr (assoc child all-nodes :test #'equal))
  607.           edge (make-contact 'edge :parent parent-window :edge-type edge-type
  608.                  :width width :height height
  609.                  :from-node node :to-node child
  610.                  :background edge-background
  611.                  :foreground edge-foreground
  612.                  :line-style edge-line-style
  613.                  :line-width edge-line-width
  614.                  :text-font edge-text-font))
  615.     (add-outgoing-edge node edge)
  616.     (add-incoming-edge child edge))
  617.       (when vertex-children (add-edges parent-window vertex-children all-nodes edge-type
  618.                        edge-children-function edge-line-style edge-line-width
  619.                        edge-foreground edge-background edge-text-font)))))
  620.  
  621.  
  622. (defun create-nodes-n-edges (root-list wind &optional &key (node-name-fun 'lisp:string) (edge-types '(:isa)))
  623.   (let* ((complete-node-list nil)
  624.      tnode
  625.      vnode
  626.      edge-line-style
  627.      edge-line-width
  628.      edge-foreground
  629.      edge-background
  630.      edge-text-font
  631.      edge-children-function
  632.      vertex-foreground
  633.      vertex-background
  634.      vertex-font-function)
  635.     (dolist (edge-type edge-types)
  636.       (setq complete-node-list (append (find-all-objects wind root-list edge-type) complete-node-list)))
  637.     (setq complete-node-list (nreverse (remove-duplicates complete-node-list :from-end t))
  638.       vertex-foreground (vertex-foreground-info wind)
  639.       vertex-background (vertex-background-info wind)
  640.       vertex-font-function (vertex-font-function-info wind))
  641.     (dotimes (n (length complete-node-list))
  642.       (setf tnode (nth n complete-node-list)
  643.         vnode (make-contact 'vertex :parent wind :object tnode
  644.                 :title (or (and (stringp tnode) tnode)
  645.                        (and (symbolp tnode) (string tnode))
  646.                        (funcall node-name-fun tnode))
  647.                 :label-font (when vertex-font-function
  648.                         (funcall vertex-font-function tnode)) ;;else, use default
  649.                 :background vertex-background :foreground vertex-foreground
  650.                 :border vertex-foreground
  651.                 :x 0 :y 0)
  652.         complete-node-list (nsubstitute (list tnode vnode) tnode complete-node-list)))
  653.     (dolist (edge-type edge-types) 
  654.       (setq edge-line-style (edge-line-style-info wind edge-type) 
  655.         edge-line-width (edge-line-width-info wind edge-type)
  656.         edge-background (edge-background-info wind edge-type)
  657.         edge-foreground (edge-foreground-info wind edge-type)
  658.         edge-text-font (edge-text-info wind edge-type)
  659.         edge-children-function (edge-children-function wind edge-type))
  660.       (add-edges wind root-list complete-node-list edge-type edge-children-function
  661.          edge-line-style edge-line-width edge-foreground edge-background edge-text-font))
  662.     complete-node-list
  663.     ))
  664.  
  665. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  666. ;; DRIVER
  667.  
  668. (defun nodes-n-edges-driver (display node-list &optional
  669.                  &key (edge-info '((:isa (:children lisp:ignore)
  670.                              (:parents lisp:ignore)
  671.                              ;(:line-style :solid)
  672.                              ;(:line-width 1)
  673.                              ;(:foreground 0)
  674.                              ;(:background 1)
  675.                              )))
  676.                  (vertex-info '((:border-width 1)
  677.                         ;(:font-function nil)
  678.                         ;(:foreground 0)
  679.                         ;(:background 1)
  680.                         ;(:edge-font "fg-13")
  681.                         ))
  682.                  graph-foreground 
  683.                  graph-background)
  684.  
  685.   (let (wind all-nodes
  686.     (xlib::*recursive-event-queue* nil)
  687.     (*graph-menu* nil))
  688.      
  689.     (unwind-protect
  690.     (catch 'quit-graph
  691.     (setf    wind (make-contact 'graph-composite :parent display  :x 0 :y 0 :width 600 :height 350
  692.                    :background graph-background
  693.                    :foreground graph-foreground
  694.                                    :compress-exposures :on))
  695.         (add-mode wind :exclusive 'ignore-action)
  696.       ;;:BACKGROUND 0 needs the logical name for WHITE
  697.       ;;(add-before-action display 'contact 'DESCRIBE)
  698.       (preprocess-vertex-info wind vertex-info)
  699.       (setq all-nodes (create-nodes-n-edges node-list wind
  700.                         :edge-types (preprocess-edge-info wind edge-info)))
  701.       (setf (root-list wind) (mapcar #'(lambda (x) (cadr (assoc x all-nodes))) node-list)) 
  702.       (setf (contact-state wind) :mapped)
  703.       (compute-graph-layout wind)
  704.       (DO ()
  705.           (())
  706.         (process-next-event display)))
  707.       (and wind (destroy wind)))
  708.  
  709.     ))
  710.  
  711.  
  712.